home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #2 / Monster Media No. 2 (Monster Media)(1994).ISO / prog_bas / codelib.zip / CODE.LIB < prev    next >
INI File  |  1994-05-01  |  51KB  |  1,687 lines
  1. [1]
  2. FrameControl is used to draw frames around controls. Pass it: the name of the form, the name of the control, the offset, and the width of the frame. 5 is a good offset, 1 or 2 a good width.
  3.  
  4.  
  5. [Code]
  6. 'Declares for FrameControl
  7. Global Const HiColor = &HFFFFFF
  8. Global Const LoColor = &H808080
  9.  
  10. Sub FrameControl (F As Form, C As Control, OffSet As Integer, Width As Integer)
  11. F.DrawWidth = Width
  12. F.forecolor = &HFFFFFF
  13.  
  14. 'bottom:
  15.     F.Line (C.Left, C.Top + C.Height + Offset)-(C.Left + C.Width, C.Top + C.Height + Offset)
  16. 'right:
  17.     F.Line (C.Left + C.Width + Offset, C.Top)-(C.Left + C.Width + Offset, C.Top + C.Height + Offset)
  18.     F.forecolor = &H808080
  19. 'top:
  20.     F.Line (C.Left - Offset * 1.5, C.Top - Offset * 1.5)-(C.Left + C.Width + Offset * 1.5, C.Top - Offset * 1.5)
  21. 'left:
  22.     F.Line (C.Left - Offset * 1.5, C.Top - Offset * 1.5)-(C.Left - Offset * 1.5, C.Top + C.Height + Offset)
  23. End Sub
  24.  
  25. [Stop]
  26. [2]
  27. GetSysDir returns the path of the Windows System directory
  28.  
  29. Pass it the name of the string you want SysPath assigned to.
  30.  
  31. [Code]
  32. 'Declares for GetSystemDir
  33. Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  34.  
  35. Sub GetSystemDir (SystemPath$)
  36. DIM Sys As String * 256   
  37.    x = GetSystemDirectory(Sys, Len(Sys))
  38.    x = InStr(1, Sys, Chr$(0))
  39.    SystemPath$ = Left$(Sys, Instr(Sys,Chr$(0))-1)
  40. End Sub
  41.  
  42. [Stop]
  43. [3]
  44. CenterForm centers the form passed to it horizontally and vertically on the screen. 
  45. [Code]
  46. Sub CenterForm (F As Form)
  47. F.Left = (Screen.Width - F.Width) / 2
  48. F.Top = (Screen.Height - F.Height) / 2
  49. End Sub
  50. [Stop]
  51. [4]
  52. Loaded tells if an app of the passed classname is loaded
  53.  
  54. [Code]
  55. 'Declares for Loaded
  56. Declare Function FindWindow Lib "user" (ByVal CName As Any, ByVal Caption As Any)
  57.  
  58. Function Loaded (ClassName$)
  59.     Loaded = FindWindow(ClassName$, 0&)
  60. End Function
  61.  
  62. [Stop]
  63. [5]
  64. Wait "secs" bfore returning  to call, allows vb to finish an executed command.
  65.  
  66. [Code]
  67. Sub WaitSecs (secs)
  68. Dim sTart!, Temp%
  69.     start! = Timer
  70.     While Timer < start! + secs +1
  71.          Temp% = DoEvents()
  72.     Wend
  73. End Sub
  74.  
  75. [Stop]
  76. [6]
  77. RestoreApp restores the windows whose handle you pass to it.
  78.  
  79. [Code]
  80. 'Declares for RestoreApp
  81. Declare Function IsIconic Lib "user" (ByVal hWnd As Any)
  82.  
  83. Sub RestoreApp (wHandle)
  84.  
  85. WM_SYSCOMMAND = &H112
  86. SC_RESTORE = &HF120
  87.   If IsIconic(Instance) Then
  88.     T = PostMessage(Instance, WM_SYSCOMMAND, SC_RESTORE, 0)
  89.     WaitSecs 1
  90.   End If
  91.  
  92. End Sub
  93.  
  94. [Stop]
  95. [7]
  96. Tracks a popup menu.
  97.  
  98. Pass it the number (going from right to left) of the menu you wish to view, the X & Y coordinates at which it should pop up (as returned by a mousedown event), the form on which the mousedown event took place (and over which the menu should appear), and the form to which the menu belongs (which may or may not be the same as the previous form).
  99.  
  100. [Code]
  101. 'TrackPopupMenu declares
  102. Declare Function TrackPopupMenu% Lib "user" (ByVal hMenu%, ByVal wFlags%, ByVal X%, ByVal Y%, ByVal r2%, ByVal hWnd%, ByVal r1&)
  103. Declare Function GetMenu% Lib "user" (ByVal hWnd%)
  104. Declare Function GetSubMenu% Lib "user" (ByVal hMenu%, ByVal nPos%)
  105.  
  106.  
  107. Sub TrackPopUp (Menu As Integer, X As Single, Y As Single, F as Form, MenuForm As Form)
  108. Const PIXEL = 3
  109. Const TWIP = 1
  110.       F.ScaleMode = PIXEL
  111.       InPixels = F.ScaleWidth
  112.       F.ScaleMode = TWIP
  113.           ix = (X + F.Left) \ (F.ScaleWidth \ InPixels)
  114.           iy = (Y + (F.Top + (F.Height - F.ScaleHeight - (F.Width - F.ScaleWidth)))) \ (F.ScaleWidth \ InPixels)
  115.           hMenu% = GetMenu(MenuForm.hWnd)
  116.           hSubMenu% = GetSubMenu(hMenu%, Menu)
  117.           '2 tells it to use right mouse button, 1 the left button
  118.       r = TrackPopupMenu(hSubMenu%, 2, ix, iy, 0, MenuForm.hWnd, 0)
  119. End Sub
  120.  
  121. [Stop]
  122. [8]
  123. MakeBeep beeps the PC's speaker a specified number of times
  124. [Code]
  125. Sub MakeBeep (Reps%)
  126. For X=1 to Reps%
  127.      Beep
  128. Next
  129. End Sub
  130. [Stop]
  131. [9]
  132. Extracts icons from a specified Exe file. 
  133.  
  134.  
  135. [Code]
  136. 'Declares for IconExtractor
  137. Const GWW_HINSTANCE = (-6)
  138. Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
  139. Declare Function ExtractIcon Lib "shell" (ByVal lpHandle As Integer, ByVal lpExe As String, ByVal lpiconindex As Integer) As Integer
  140. Declare Function DrawIcon Lib "USER" (ByVal lpHandle As Integer, ByVal xcoord As Integer, ByVal ycoord As Integer, ByVal Hicon As Integer) As Integer
  141.  
  142. Sub IconExtractor (ExeFile$, F as Form, Pic as Picture)
  143. Handle = F.hWnd
  144. z = SCREEN.HEIGHT
  145.     Select Case z
  146.         Case 7000
  147.             X = 2: Y = 1
  148.         Case 7200
  149.             X = 3: Y = 0
  150.         Case 9000
  151.             X = 3: Y = 0
  152.         Case Is > 9000
  153.             X = 8: Y = 4
  154.     End Select
  155.                 
  156.     Static Looper
  157.     Looper = Looper + 1
  158.     Inst = GetWindowWord(Handle, GWW_HINSTANCE)
  159.     Hicon = ExtractIcon(Inst, ExeFile$, Looper - 1)
  160.     If Hicon = 0 Then
  161.         If Looper > 0 Then
  162.             Hicon = ExtractIcon(Inst, ExeFile$, 0)
  163.             Looper = 1
  164.         Else Beep: Exit Sub
  165.         End If
  166.     End If
  167.     F.Pic.CLS
  168.     Draw = DrawIcon(F.Pic.hDC, X, Y, Hicon)
  169. End Sub
  170.  
  171. [Stop]
  172. [10]
  173. FormStayOnTop establishes the specified window as the topmost window no matter which window is active.
  174.  
  175. Pass it the handle of the window you want to make topmost (or for which you wish to end that condition) and a true/false flag to indicate whether it should be topmost.
  176.  
  177. [Code]
  178. 'Declares for FormStayOnTop
  179. Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
  180.  
  181. Sub FormStayOnTop (Handle%, OnTop%)
  182. Const Swp_Nosize = &H1
  183. Const SWP_Nomove = &H2
  184. Const Swp_NoActivate = &H10
  185. Const Swp_ShowWindow = &H40
  186. Const Hwnd_TopMost = -1
  187. Const Hwnd_NoTopMost = -2
  188.  
  189. wFlags = SWP_Nomove Or Swp_Nosize Or Swp_ShowWindow Or Swp_NoActivate
  190. Select Case OnTop%
  191.      Case True
  192.         PosFlag = Hwnd_TopMost
  193.      Case False
  194.          PosFlag = Hwnd_NoTopMost
  195.      End Select
  196. SetWindowPos Handle%, PosFlag, 0, 0, 0, 0, wFlags
  197. End Sub
  198.  
  199. [Stop]
  200. [11]
  201. Testlength can be used to test whether more than a specified number of characters has been entered into a textbox. If so, it deletes backwards from the insertion point until the text length is within the specified limit.
  202.  
  203. [Code]
  204. 'Declares for TestLength
  205. Global Const MB_ICONEXCLAMATION = 48
  206.  
  207. Sub TestLength (C As Control, L As Integer)
  208. Select Case Len(C.Text)
  209.     Case Is <= L
  210.              Exit Sub
  211.     Case Else
  212.             MsgBox "This field is limited to " + Str$(L) + " characters only! ", MB_ICONEXCLAMATION, "CopyFlow"
  213.             LeftText$ = Left$(C.Text, C.SelStart)
  214.             RightText$ = Mid$(C.Text, C.SelStart + 1)
  215.             LeftText$ = Left$(LeftText$, L - Len(RightText$))
  216.             C.Text = LeftText$ + RightText$
  217.     End Select
  218. End Sub
  219.  
  220.  
  221. [Stop]
  222. [12]
  223. Routine to locate the progenitor of a series of Windows
  224. [Code]
  225. 'Declares for Find Parent
  226. Declare Function GetParent Lib "User" (ByVal hWnd As Integer) As Integer
  227.  
  228.  
  229. Function FindProgentor (WinHand As Integer) As Integer
  230.      Parent% = GetParent(WinHand%)
  231.      OldParent%=Parent%
  232.      'Get the parent of the parent if any
  233.      Do While Parent%
  234.           OldParent% = Parent%
  235.           Parent% = GetParent%(OldParent%)
  236.          ' Debug.Print Parent%
  237.      Loop
  238. Parent%=OldParent%
  239. FindProgenitor = Parent%
  240. End Function
  241.  
  242. [Stop]
  243. [13]
  244. The Exists%() function returns a value of TRUE if the specified file exists, or FALSE if it doesn't.
  245. [Code]
  246. Function Exists% (F$)
  247. On Error Resume Next
  248. X& = FileLen(F$)
  249. If X& Then Exists% = True
  250. End Function
  251.  
  252. [Stop]
  253. [14]
  254. Function determines if passed pathname is valid
  255.  
  256. [Code]
  257. '------------------------------------------------------
  258. ' Function:   IsValidPath as integer
  259. ' arguments:  DestPath$ a string that is a full path
  260. ' DefaultDrive$  the default drive.  eg.  "C:"
  261. '
  262. '  If DestPath$ does not include a drive specification,
  263. '  IsValidPath uses Default Drive
  264. '
  265. '  When IsValidPath is finished, DestPath$ is reformated
  266. '  to the format "X:\dir\dir\dir\"
  267. '
  268. '  Result:  True (-1) if path is valid.
  269. '  False (0) if path is invalid
  270. '-------------------------------------------------------
  271.  
  272. Function IsValidPath (DestPath$, ByVal DefaultDrive$) As Integer
  273.  
  274.     '----------------------------
  275.     ' Remove left and right spaces
  276.     '----------------------------
  277.     DestPath$ = RTrim$(LTrim$(DestPath$))
  278.     
  279.     '-----------------------------
  280.     ' Check Default Drive Parameter
  281.     '-----------------------------
  282.     If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then
  283.         MsgBox "Bad default drive parameter specified in IsValidPath Function.  You passed,  """ + DefaultDrive$ + """.  Must be one drive letter and "":"".  For example, ""C:"", ""D:""...", 64, "Setup Kit Error"
  284.         GoTo parseErr
  285.     End If
  286.     
  287.     '-------------------------------------------------------
  288.     ' Insert default drive if path begins with root backslash
  289.     '-------------------------------------------------------
  290.     If Left$(DestPath$, 1) = "\" Then
  291.         DestPath$ = DefaultDrive + DestPath$
  292.     End If
  293.     
  294.     '-----------------------------
  295.     ' check for invalid characters
  296.     '-----------------------------
  297.     On Error Resume Next
  298.     tmp$ = Dir$(DestPath$)
  299.     If Err <> 0 Then
  300.         GoTo parseErr
  301.     End If
  302.     
  303.     '-----------------------------------------
  304.     ' Check for wildcard characters and spaces
  305.     '-----------------------------------------
  306.     If (InStr(DestPath$, "*") <> 0) GoTo parseErr
  307.     If (InStr(DestPath$, "?") <> 0) GoTo parseErr
  308.     If (InStr(DestPath$, " ") <> 0) GoTo parseErr
  309.              
  310.     '------------------------------------------
  311.     ' Make Sure colon is in second char position
  312.     '------------------------------------------
  313.     If Mid$(DestPath$, 2, 1) <> Chr$(58) Then GoTo parseErr
  314.     
  315.     '-------------------------------
  316.     ' Insert root backslash if needed
  317.     '-------------------------------
  318.     If Len(DestPath$) > 2 Then
  319.       If Right$(Left$(DestPath$, 3), 1) <> "\" Then
  320.         DestPath$ = Left$(DestPath$, 2) + "\" + Right$(DestPath$, Len(DestPath$) - 2)
  321.       End If
  322.     End If
  323.  
  324.     '-------------------------
  325.     ' Check drive to install on
  326.     '-------------------------
  327.     drive$ = Left$(DestPath$, 1)
  328.     ChDrive (drive$)                                                        ' Try to change to the dest drive
  329.     If Err <> 0 Then GoTo parseErr
  330.     
  331.     '-----------
  332.     ' Add final \
  333.     '-----------
  334.     If Right$(DestPath$, 1) <> "\" Then
  335.         DestPath$ = DestPath$ + "\"
  336.     End If
  337.     
  338.     '-------------------------------------
  339.     ' Root dir is a valid dir
  340.     '-------------------------------------
  341.     If Len(DestPath$) = 3 Then
  342.         If Right$(DestPath$, 2) = ":\" Then
  343.             GoTo ParseOK
  344.         End If
  345.     End If    
  346.  
  347.     '------------------------
  348.     ' Check for repeated Slash
  349.     '------------------------
  350.     If InStr(DestPath$, "\\") <> 0 Then GoTo parseErr
  351.         
  352.     '--------------------------------------
  353.     ' Check for illegal directory names
  354.     '--------------------------------------
  355.     legalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~."
  356.     BackPos = 3
  357.     forePos = InStr(4, DestPath$, "\")
  358.     Do
  359.         temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1)
  360.         
  361.         '----------------------------
  362.         ' Test for illegal characters
  363.         '----------------------------
  364.         For i = 1 To Len(temp$)
  365.             If InStr(legalChar$, UCase$(Mid$(temp$, i, 1))) = 0 Then GoTo parseErr
  366.         Next i
  367.  
  368.         '-------------------------------------------
  369.         ' Check combinations of periods and lengths
  370.         '-------------------------------------------
  371.         periodPos = InStr(temp$, ".")
  372.         length = Len(temp$)
  373.         If periodPos = 0 Then
  374.             If length > 8 Then GoTo parseErr                             ' Base too long
  375.         Else
  376.             If periodPos > 9 Then GoTo parseErr                      ' Base too long
  377.             If length > periodPos + 3 Then GoTo parseErr        ' Extension too long
  378.             If InStr(periodPos + 1, temp$, ".") <> 0 Then GoTo parseErr' Two periods not allowed
  379.         End If
  380.  
  381.         BackPos = forePos
  382.         forePos = InStr(BackPos + 1, DestPath$, "\")
  383.     Loop Until forePos = 0
  384.  
  385. ParseOK:
  386.     IsValidPath = True
  387.     Exit Function
  388.  
  389. parseErr:
  390.     IsValidPath = False
  391.  
  392. End Function
  393.  
  394.  
  395. [Stop]
  396. [15]
  397. Creates the passed path. Create the path contained in DestPath$
  398. First char must be drive letter, followed by
  399. a ":\" followed by the path, if any.
  400.  
  401.  
  402. [Code]
  403. Function CreatePath (ByVal DestPath$) As Integer
  404.     Screen.MousePointer = 11
  405.  
  406.     '---------------------------------------------
  407.     ' Add slash to end of path if not there already
  408.     '---------------------------------------------
  409.     If Right$(DestPath$, 1) <> "\" Then
  410.         DestPath$ = DestPath$ + "\"
  411.     End If
  412.           
  413.  
  414.     '-----------------------------------
  415.     ' Change to the root dir of the drive
  416.     '-----------------------------------
  417.     On Error Resume Next
  418.     ChDrive DestPath$
  419.     If Err <> 0 Then GoTo errorOut
  420.     ChDir "\"
  421.  
  422.     '-------------------------------------------------
  423.     ' Attempt to make each directory, then change to it
  424.     '-------------------------------------------------
  425.     BackPos = 3
  426.     forePos = InStr(4, DestPath$, "\")
  427.     Do While forePos <> 0
  428.         temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1)
  429.  
  430.         Err = 0
  431.         MkDir temp$
  432.         If Err <> 0 And Err <> 75 Then GoTo errorOut
  433.  
  434.         Err = 0
  435.         ChDir temp$
  436.         If Err <> 0 Then GoTo errorOut
  437.  
  438.         BackPos = forePos
  439.         forePos = InStr(BackPos + 1, DestPath$, "\")
  440.     Loop
  441.                  
  442.     CreatePath = True
  443.     Screen.MousePointer = 0
  444.     Exit Function
  445.                  
  446. errorOut:
  447.     MsgBox "Error While Attempting to Create Directories on Destination Drive.", 48, "SETUP"
  448.     CreatePath = False
  449.     Screen.MousePointer = 0
  450.  
  451. End Function
  452.  
  453.  
  454. [Stop]
  455. [16]
  456. Creates a Program Manager group.
  457.  
  458.  
  459.  
  460. [Code]
  461. Sub CreateProgManGroup (x As Form, GroupName$, GroupPath$)
  462. ' Procedure: CreateProgManGroup
  463. ' Arguments: X           The Form where a Label1 exist
  464. ' GroupName$  A string that contains the group name
  465. ' GroupPath$  A string that contains the group file
  466. ' name  'myapp.grp'
  467.     
  468.     Screen.MousePointer = 11
  469.     
  470.     '----------------------------------------------------------------------
  471.     ' Windows requires DDE in order to create a program group and item.
  472.     ' Here, a Visual Basic label control is used to generate the DDE messages
  473.     '----------------------------------------------------------------------
  474.     On Error Resume Next
  475.  
  476.     
  477.     '--------------------------------
  478.     ' Set LinkTopic to PROGRAM MANAGER
  479.     '--------------------------------
  480.     x.Label1.LinkTopic = "ProgMan|Progman"
  481.     x.Label1.LinkMode = 2
  482.     For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
  483.       z% = DoEvents()                                       ' process DDE Execute.  This is redundant but needed
  484.     Next                                                             ' for debug windows.
  485.     x.Label1.LinkTimeout = 100
  486.  
  487.  
  488.     '---------------------
  489.     ' Create program group
  490.     '---------------------
  491.     x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]"
  492.  
  493.  
  494.     '-----------------
  495.     ' Reset properties
  496.     '-----------------
  497.     x.Label1.LinkTimeout = 50
  498.     x.Label1.LinkMode = 0
  499.     
  500.     Screen.MousePointer = 0
  501. End Sub
  502.  
  503.  
  504.  
  505. [Stop]
  506. [17]
  507. Creates a program manager item
  508.  
  509.  
  510. [Code]
  511. Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$)
  512.  
  513. ' Procedure: CreateProgManItem
  514. '
  515. ' Arguments: X           The form where Label1 exists
  516. '
  517. '            CmdLine$    A string that contains the command
  518. '                        line for the item/icon.
  519. '                        i.e 'c:\myapp\setup.exe'
  520. '
  521. '            IconTitle$  A string that contains the item's
  522. '                        caption
  523.     
  524.     Screen.MousePointer = 11
  525.     
  526.     '----------------------------------------------------------------------
  527.     ' Windows requires DDE in order to create a program group and item.
  528.     ' Here, a Visual Basic label control is used to generate the DDE messages
  529.     '----------------------------------------------------------------------
  530.     On Error Resume Next
  531.  
  532.  
  533.     '---------------------------------
  534.     ' Set LinkTopic to PROGRAM MANAGER
  535.     '---------------------------------
  536.     x.Label1.LinkTopic = "ProgMan|Progman"
  537.     x.Label1.LinkMode = 2
  538.     For i% = 1 To 10                                         ' Loop to ensure that there is enough time to
  539.       z% = DoEvents()                                        ' process DDE Execute.  This is redundant but needed
  540.     Next                                                     ' for debug windows.
  541.     x.Label1.LinkTimeout = 100
  542.  
  543.     
  544.     '------------------------------------------------
  545.     ' Create Program Item, one of the icons to launch
  546.     ' an application from Program Manager
  547.     '------------------------------------------------
  548.     x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]"
  549.     
  550.     '-----------------
  551.     ' Reset properties
  552.     '-----------------
  553.     x.Label1.LinkTimeout = 50
  554.     x.Label1.LinkMode = 0
  555.     
  556.     Screen.MousePointer = 0
  557. End Sub
  558.  
  559.  
  560.  
  561. [Stop]
  562. [18]
  563. Draws a 3D frame on a form. Use on a grey form.
  564.  
  565. [Code]
  566. 'Declares for Frame
  567. Global Const HiColor = &HFFFFFF
  568. Global Const LoColor = &H808080
  569.  
  570. Sub Frame (F As Form, l, t, h, w, Style)
  571. Dim BigOffSet
  572. BigOffSet = 10
  573.  
  574. 'F.DrawWidth = Style
  575.     F.DrawWidth = 1
  576.     F.ForeColor = HiColor:  If Style = 2 Then F.ForeColor = LoColor
  577.  
  578. 'bottom:
  579. 'F.Line (L + F.DrawWidth, T + H + offset)-(L + W - F.DrawWidth, T + H + offset)
  580.     F.Line (l + F.DrawWidth, t + h)-(l + w - F.DrawWidth, t + h)
  581.  
  582. 'right:
  583.     F.Line (l + w, t + F.DrawWidth)-(l + w, t + h - F.DrawWidth)
  584.     F.ForeColor = LoColor: If Style = 2 Then F.ForeColor = HiColor
  585.  
  586. 'top:
  587.     F.Line (l - BigOffSet + F.DrawWidth, t - BigOffSet)-(l + w + BigOffSet - F.DrawWidth, t - BigOffSet)
  588.  
  589.  'left:
  590.     F.Line (l - BigOffSet, t + F.DrawWidth - BigOffSet)-(l - BigOffSet, t + h + BigOffSet - F.DrawWidth)
  591.  
  592. End Sub
  593.  
  594.  
  595.  
  596. [Stop]
  597. [19]
  598. obtain LoWord of Long
  599.  
  600. [Code]
  601. Function LoWord%(LongVal&)
  602.     LOWORD% = LongVal& AND 65535
  603. End Function
  604.  
  605.  
  606.  
  607. [Stop]
  608. [20]
  609. obtain hiword of long
  610.  
  611. [Code]
  612. Function HIWORD%(LongVal&)
  613.     HIWORD% = LongVal& \ 65536 ' (note: '\', not '/')
  614. End Function
  615.  
  616. [Stop]
  617. [21]
  618. Creates an Alert Box using specified text and App.Title
  619. [Code]
  620. Sub Alert (Mess$)
  621. '  * creates an Alert box with an OK button
  622. MsgBox Mess$, 48, App.Title
  623. End Sub
  624.  
  625. [Stop]
  626. [22]
  627. Function creates confirmation box using specified text, returns True if Yes button pressed, False if No button pressed
  628. [Code]
  629. Function Confirm% (Ask$)
  630. If MsgBox(Ask$, 52, App.Title) = 6 Then Confirm% = True
  631. End Function
  632.  
  633. [Stop]
  634. [23]
  635. Draws what looks like a 3D frame around the edge of a borderless label control
  636. [Code]
  637. Sub Draw3dFrame (f As Form, C As Label)
  638. 'draw label size you want frame -- no autosize
  639. 'label font must be same as form font!
  640. Const White = &HFFFFFF
  641. Const DarkGrey = &H808080
  642. Dim X1%, X2%, Y1%, Y2%, FrameHeight%, FrameWidth%, FrameLeft%, FrameTop%
  643. f.DrawWidth = 1
  644. FrameLeft% = C.Left
  645. FrameTop% = C.Top
  646. FrameHeight% = C.Height
  647. FrameWidth% = C.Width
  648. 'Draw left of label
  649. X1% = FrameLeft% - 60
  650. X2% = FrameLeft% - 180
  651. Y1% = FrameTop% + (f.TextHeight(C.Caption) / 2) - 60
  652. f.ForeColor = DarkGrey
  653. f.Line (X1%, Y1%)-(X2, Y1%)
  654. Y1% = Y1% + 20
  655. f.ForeColor = White
  656. f.Line (X1%, Y1%)-(X2, Y1%)
  657. 'Draw left side
  658. Y2% = Y1% + FrameHeight%
  659. f.ForeColor = DarkGrey
  660. f.Line (X2%, Y1%)-(X2%, Y2%)
  661. X2% = X2% + 20
  662. f.ForeColor = White
  663. f.Line (X2%, Y1%)-(X2%, Y2%)
  664. 'draw bottom
  665. X1% = X2%
  666. X2% = FrameLeft% + FrameWidth%
  667. f.ForeColor = DarkGrey
  668. f.Line (X1%, Y2)-(X2%, Y2%)
  669. Y2% = Y2% + 15
  670. f.ForeColor = White
  671. f.Line (X1%, Y2)-(X2%, Y2%)
  672. 'draw right
  673. Y1% = FrameTop% + (f.TextHeight(C.Caption) / 2) - 60
  674. f.Line -(X2%, Y1%)
  675. f.ForeColor = DarkGrey
  676. X1% = X2% - 20
  677. f.Line (X1%, Y2% - 20)-(X1%, Y1% + 20)
  678. 'draw top to label right
  679. X2% = FrameLeft% + f.TextWidth(C.Caption) + 60
  680. f.Line (X1%, Y1% - 15)-(X2%, Y1% - 15)
  681. f.ForeColor = White
  682. f.Line (X1%, Y1%)-(X2%, Y1%)
  683. End Sub
  684.  
  685. [Stop]
  686. [24]
  687. Function returns a passed path with backslash at end.
  688.  
  689. [Code]
  690. Function FixPath$ (Test$)
  691. 'sticks a backslash on the end of test$ if there's
  692. 'not one there already
  693. Dim T$
  694. T$ = Test$
  695.      If Right$(T$, 1) <> "\" Then T$ = T$ + "\"
  696.      FixPath$ = T$
  697. End Function
  698.  
  699.  
  700. [Stop]
  701. [25]
  702. Function returns handle of first window matching partial name parameter
  703.  
  704.  
  705. [Code]
  706. 'Declares for SearchWindowLIst
  707. Declare Function GetWindow% Lib "USER" (ByVal hWnd%, ByVal wCmd%)
  708. Global Const GW_HWNDFIRST = 0
  709. Global Const GW_HWNDNEXT = 2
  710. Declare Function GetWindowText Lib "User" (ByVal hWnd As Integer, ByVal lpString As String, ByVal aint As Integer) As Integer
  711.  
  712. Function SearchWindowList% (Cap$)
  713. 'returns handle of first window that matches partial
  714. 'caption passed to function
  715. SearchWindowList% = 0
  716. Dim w%, Y%, winCap As String * 255
  717.  
  718.     w% = GetWindow%(MAKerMain.hWnd, GW_HWNDFIRST)
  719.     Do While w% <> 0
  720.          Y% = GetWindowText(w%, winCap, 254)
  721.          If Left$(winCap, Len(Cap$)) = Cap$ Then
  722.             SearchWindowList% = w%
  723.             Exit Do
  724.          End If
  725.         w% = GetWindow%(w%, GW_HWNDNEXT)
  726.    Loop
  727.  
  728. End Function
  729.  
  730.  
  731.  
  732. [Stop]
  733. [26]
  734. Function removes path from fully-qualified file name, returns file name only.
  735.  
  736. [Code]
  737. Function StripPath$ (T$)
  738. Dim x%, ct%
  739. StripPath$ = T$
  740.     x% = InStr(T$, "\")
  741.     Do While x%
  742.        ct% = x%
  743.        x% = InStr(ct% + 1, T$, "\")
  744.     Loop
  745.     If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
  746. End Function
  747.  
  748.  
  749. [Stop]
  750. [27]
  751. Trims spaces CHR$(0)'s from string returned by API function
  752.  
  753. [Code]
  754. Function FixAPIString$ (ByVal test$)
  755.     FixAPIString$ = Trim(Left$(test$, InStr(test$, Chr$(0)) - 1))
  756. End Function
  757.  
  758.  
  759. [Stop]
  760. [28]
  761. Finds and restores a previous running instance of your app
  762. [Code]
  763. Sub FindAndRestorePrevInstance (Cap$)
  764. Dim X%
  765. If App.PrevInstance Then
  766.    AppActivate Cap$
  767.    SendKeys ("% R")
  768.    End
  769. End If
  770. End Sub
  771.  
  772. [Stop]
  773. [29]
  774. Open the System INI File and reads one section value
  775.  
  776. [Code]
  777. 'Declares for Get System INI-File
  778. Value$ = GetSysINI (Section$, Key$)
  779.  
  780.  
  781. 'Function GetSysINI (Section$, key$) As String
  782. 'Dim retVal As String, worked As Integer
  783.  
  784. '  ' ** Open the System.INI and read the 'SECTION' out
  785. '  retVal = String$(255, 0)
  786. '  ' ** Standard API function to read profile string !
  787. '  worked = GetPrivateProfileString(Section, key, "", retVal, Len(retVal), "System.ini")
  788. '   If worked = 0 Then
  789. '      ' ** We couldn't identify this string
  790. '      GetSysINI = "unknown"
  791. '   Else
  792. '      ' ** Cut the Itemname just get the values
  793. '      GetSysINI = Left(retVal, worked)
  794. '   End If
  795. 'End Function
  796.  
  797. [Stop]
  798. [30]
  799. Opens the WIN INI File and returns one value of a specific section
  800.  
  801. [Code]
  802. 'Declares for Get Win INI-File
  803. Value$ = GetWinINI (Section$, Key$)
  804.  
  805.  
  806. 'Function GetWinINI (Section$, key$) As String
  807. 'Dim retVal As String, AppName As String, worked As Integer
  808.  
  809. '  ' ** Open the System.INI and read the 'SECTION' out
  810. '  retVal = String$(255, 0)
  811. '  ' ** Standard API function to read profile string !
  812. '  worked = GetProfileString(Section, key, "", retVal, Len(retVal))
  813. '  If worked = 0 Then
  814. '     ' ** We couldn't identify this string
  815. '     GetWinINI = "unknown"
  816. '  Else
  817. '      GetWinINI = Left(retVal, worked)
  818. '  End If
  819. 'End Function
  820.  
  821. [Stop]
  822. [31]
  823. Write Profile String to INI-File, must include INI-Filename
  824.  
  825. [Code]
  826. 'Declares for Write P-Profile String
  827. R% = SaveProfile (Section$, EntryName$, EntryValue, FName$)
  828.  
  829.  
  830. 'Function SaveProfile (Section$, EntryName$, EntryValue, FName$) As Integer
  831. 'Dim X%
  832.  
  833. '  X% = WritePrivateProfileString%(Section$, EntryName$, Str$(EntryValue), FName$)
  834. '  If X% = 0 Then
  835. '      SaveProfile = False
  836. '  Else
  837. '      SaveProfile = True
  838. '  End If
  839.  
  840. 'End Function
  841.  
  842. [Stop]
  843. [32]
  844. Expanding TAB-charater and convert them to ASCii(255)
  845.  
  846. [Code]
  847. 'Declares for Expand TAB-character
  848. R$ = ExpandTab (X1$, NumSpaces%)
  849.  
  850.  
  851. 'Static Function ExpandTab$ (X1$, NumSpaces%)
  852. 'Dim Tabs%, Where%, Sp%, Length%, Work$, X%
  853. '    Tabs% = InCount%(X1$, Chr$(9))              '-> Find Number of tab Chars.
  854. '    If Tabs% Then                               '   Are there any?
  855. '                                                '   make room for new string
  856. '       Work$ = Space$(Len(X1$) + 1 + (NumSpaces% - 1) * Tabs%)
  857. '       LSet Work$ = X1$ + Chr$(0)               '-> Put existing string in it
  858. '                                                '   and a char. 0 for later
  859. '       Where% = 1                               '   Set search position to 1
  860. '       For X% = 1 To Tabs%                      '-> Do each tab
  861. '                                                '   find the next Tab character
  862. '           Where% = InStr(Where%, Work$, Chr$(9)) + 1
  863. '           Length% = Where% - 2                 '-> Calc length of left part
  864. '                                                '-> Calc spaces to next tab stop
  865. '           Sp% = Length% + NumSpaces% - (Length% Mod NumSpaces%) - Length%
  866. '           If Where% > 1 Then Mid$(Work$, Where% - 1) = Space$(Sp%) + Mid$(Work$, Where%)
  867. '       Next '(Insert the spaces)                 -> Assign the function looking
  868. '                                                '   for the char. 0
  869. '       ExpandTab$ = Left$(Work$, InStr(Work$, Chr$(0)) - 1)
  870. '    Else                                        '-> No tabs. Just assign the
  871. '       ExpandTab$ = X1$                          '  function
  872. '    End If
  873. 'End Function
  874.  
  875. [Stop]
  876. [33]
  877. Adding leading Zeros to a number i.e:  '00000123'. Returns new Number as string !
  878.  
  879. [Code]
  880. 'Declares for Pad Function
  881. Number$ = Pad (X!, Places%)
  882.  
  883.  
  884. 'Static Function Pad$ (X!, Places%)
  885. 'Dim X1$
  886.  
  887. '    X1$ = Str$(X!)                       'make a string version of the number
  888.  
  889. '    If Len(LTrim$(X1$)) > Places% Then   '  if after trimming a possible leading
  890. '       Pad$ = "%" + X1$                                '  blank it's too long, add a "%"
  891. '       Exit Function                                        '  to show an error and go away
  892. '    End If
  893.  
  894. '    X1$ = Mid$(X1$, 2)                                 '  discard the leading blank or "-" sign
  895. '    Pad$ = Mid$("-", Sgn(X!) + 2) + String$(Places% - Len(X1$) + (Sgn(X!) = -1), "0") + X1$
  896. '                        '   ^add minus if needed           ^create the zeros                   ^less one if negative
  897. 'End Function
  898.  
  899. [Stop]
  900. [34]
  901. Center Form on current screen
  902. [Code]
  903. 'Declares for Center Form on Screen
  904. Center Form
  905.  
  906.  
  907. 'Sub CenterFormOld (Frm As Form)
  908. '  ' ** Center Form on screen
  909. '  Frm.Top = Screen.Height / 2 - Frm.Height / 2
  910. '  Frm.Left = Screen.Width / 2 - Frm.Width / 2
  911. 'End Sub
  912. [Stop]
  913. [35]
  914. Cut the last Char in Str$ if not '0'
  915. [Code]
  916. 'Declares for Cut Last Character in Str$
  917. NewStr$ = CutCharacter (Text$)
  918.  
  919.  
  920. 'Function CutCharacter (Text$) As String
  921. ' ' ** Cut the last character in a string, before we do any API-call.
  922. ' '    The string must be filled with chr(255)=space and not end with '0'.
  923. ' Text$ = RTrim$(Text$)
  924.  
  925. '  ' ** Check string
  926. '  If Right$(Text$, 1) = Chr$(0) Then
  927. '    ' ** Cut one character
  928. '    Text$ = Left$(Text$, Len(Text$) - 1)
  929. '  End If
  930.  
  931. ' ' ** Store new string.
  932. ' CutCharacter$ = Text$
  933.  
  934. 'End Function
  935. [Stop]
  936. [36]
  937. Get DOS Version Number
  938. [Code]
  939. 'Declares for Get DOS Version
  940. DosVersion ()
  941.  
  942.  
  943. 'Function DosVersion ()
  944. 'Dim Ver As Long, DosVer As Long
  945. '    ' ** Use API-function to get the DOS version number
  946. '    Ver = GetVersion()
  947. '    ' ** Calculat the long integer into short readable form
  948. '    DosVer = Ver \ &H10000
  949. '    DosVersion = Format((DosVer \ 256) + ((DosVer Mod 256) / 100), "Fixed")
  950. 'End Function
  951. [Stop]
  952. [37]
  953. Checks if file exists in current Dir.
  954. [Code]
  955. 'Declares for File Exist?
  956. R% = FileExists (FILE$)
  957.  
  958.  
  959. 'Function FileExists (FILE$) As Integer
  960. '  '** Check if File exist on path
  961. '  If (Dir(FILE$) <> "") Then
  962. '    FileExists = True
  963. '  Else
  964. '    FileExists = False
  965. '  End If
  966. 'End Function
  967. [Stop]
  968. [38]
  969. Checks if Filename is valid. Checks if there are any control char. Function is Flag controlled, means it can check Pathnames or Filenames depending on Flag. 1= Filename, 2=Pathname, Flag Type is Int byVal.
  970.  
  971. [Code]
  972. 'Declares for Filename is Valid?
  973. R% = FNameIsValid (VFName$, StrFlag%)
  974.  
  975.  
  976. 'Function FNameIsValid (VFName$, ByVal StrFlag%) As Integer
  977. 'Dim KeyAscii%
  978.  
  979. '' ** START always positive YEAH !
  980. ' FNameIsValid = True
  981. '  ' ** Sting is empty quit now.
  982. '  If (VFName = "") Or (VFName = " ") Then
  983. '     FNameIsValid = False
  984. '     Exit Function
  985. '  End If
  986.  
  987. '  ' ** Test Routines: check if ascii characters are OK.
  988. '  Select Case StrFlag%
  989. '     Case 1
  990. '     ' ---------> Check valid FILENAME !
  991. '      Select Case KeyAscii
  992. '        Case Is < Asc("!")
  993. '         FNameIsValid = False
  994. '        Case Is > Asc("z")
  995. '         FNameIsValid = False
  996. '        Case Is = Asc("┤")
  997. '         FNameIsValid = False
  998. '        Case Is = Asc(",")
  999. '         FNameIsValid = False
  1000. '        Case Is = Asc(":")
  1001. '         FNameIsValid = False
  1002. '        Case Is = Asc("/")
  1003. '         FNameIsValid = False
  1004. '        Case Is = Asc("\")
  1005. '         FNameIsValid = False
  1006. '      End Select
  1007. '     Case 2
  1008. '     ' ---------> Check valid PATHNAME !
  1009. '      Select Case KeyAscii
  1010. '        Case Is < Asc("!")
  1011. '         FNameIsValid = False
  1012. '        Case Is > Asc("z")
  1013. '         FNameIsValid = False
  1014. '        Case Is = Asc("┤")
  1015. '         FNameIsValid = False
  1016. '        Case Is = Asc(",")
  1017. '         FNameIsValid = False
  1018. '        Case Is = Asc(":")
  1019. '         FNameIsValid = False
  1020. '      End Select
  1021. '     Case 3
  1022. '     ' ** RESERVED for later use **
  1023. '     Case 4
  1024. '     ' ** RESERVED **
  1025. '     Case Is > 4
  1026. '     ' ---------> Illegal Call !
  1027. '     Exit Function
  1028. '     Case 0
  1029. '     ' ---------> Illegal Call, probably a bug ?
  1030. '     Exit Function
  1031. '  End Select
  1032. 'End Function
  1033.  
  1034. [Stop]
  1035. [39]
  1036. Determine the Graphic Card by calculating the max screen resolution. Returns a number which refers to the graphic card type: 1=CGA, 2=EGA, 3=VGA, 4=HVGA, 5=SVGA....
  1037.  
  1038. [Code]
  1039. 'Declares for Get Graphic Adapter
  1040. Card% = GetGraphicCard ()
  1041.  
  1042.  
  1043. 'Function GetGraphicCard () As Integer
  1044. 'Dim y%, X%
  1045.  
  1046. ''   1.)  --> SWITCH TO TWIPS FIRST: 1 cm = 567 twips        
  1047. ''   2.)  --> Multiplication Factor = 15 !                                        
  1048. ''   3.)  --> Example: 480 x 15 = 7200 twips vertically               
  1049. ''---------------------------------------------------------------------------------
  1050. '   ' ** Make sure we are in Twips mode !
  1051. '   ScaleMode = 2
  1052. '   y% = Screen.Height ' -> Vertical Resolution
  1053. '   X% = Screen.Width ' -> Horiyontal Resolution
  1054.  
  1055. '    If y% = 6000 Then
  1056. '      GetGraphicCard% = 1     ' -> "CGA"
  1057. '    ElseIf y% <= 7000 Then
  1058. '      GetGraphicCard% = 2     ' -> "EGA"
  1059. '    ElseIf y% <= 7200 Then
  1060. '      GetGraphicCard% = 3     ' -> "VGA 640x480"
  1061. '    ElseIf y% > 9000 Then
  1062. '      GetGraphicCard% = 4     ' -> "VGA 800x600"
  1063. '    ElseIf y% > 11000 Then
  1064. '      GetGraphicCard% = 5     ' -> "VGA 1024x768"
  1065. '    ElseIf y% > 15000 Then
  1066. '      GetGraphicCard% = 6     ' -> "VGA 1280x1024"
  1067. '    ElseIf y% > 19000 Then
  1068. '      GetGraphicCard% = 7     ' -> "VGA 1600x1280"
  1069. '    ElseIf y% > 22000 And y% < 5000 Then
  1070. '      GetGraphicCard% = 0     ' -> "Unknown Type"
  1071. '    End If
  1072. ''->  RESOLUTION: up to 1600x1280 ->  END Graphic-Adapter Test 
  1073. 'End Function
  1074.  
  1075. [Stop]
  1076. [40]
  1077. Split full Filename into Filename, Pathname, Extension, Filename w/o Extens. The function is Flag driven, 1=Drivechar, 2=Pathname, 3=full Filename, 4=Extension, 5=Patterns/Wildcards, 6=pur Filename....
  1078.  
  1079. [Code]
  1080. 'Declares for Split Filename
  1081. Name$ = SplitFileName (ByVal FName$, ByVal GetBack%)
  1082.  
  1083.  
  1084. 'Function SplitFileName (ByVal FName$, ByVal GetBack%) As String
  1085.  
  1086.  
  1087. 'Dim NODrive%, NOPath%, NOFile%, NOExt%, LenF%
  1088. 'Dim NameOfPath$, NameOFDrive$, NameOFPattern$
  1089. 'Dim NameOFFile$, NameOFPurFile$, NameOFExt$, NameOfPathNoSL$
  1090.  
  1091. '' Meanings(Dim): {BS = "\"} and {PT = "."} and {DP = ":"}       
  1092.  
  1093. 'Dim BS%, PT%, DP%
  1094. '  Valid Flags (GetBack%) setting  are: 1,2,3,4,5,6,7                  
  1095. ' ==================================================                   
  1096. '                                                                       
  1097. '   -> 1:  Returns Drive in Letterform incl. ":" (i.e "A:").           
  1098. '   -> 2:  Returns Pathname as checked Pathstring inc. "\" at the end.   
  1099. '   -> 3:  Returns Filename incl. Extension (i.e: "TEST.DOC").          
  1100. '   -> 4:  Returns Extension as 4 character string (i.e: ".txt").       
  1101. '   -> 5:  Returns Pattern incl. Wildcards or ? (i.e: "*.EXE").          
  1102. '   -> 6:  Returns pur Filename, no extension (i.e: "TEST").            
  1103. '   -> 7:  Returns Pathname as checked Pathstring without "\" at end.    
  1104. '                                                                        
  1105. '-> STARTVALUES !
  1106. ' NOPath% = False
  1107. ' NODrive% = False
  1108. ' NOFile% = False
  1109. ' NOExt% = False
  1110. ' BS% = BS1% = 0
  1111.  
  1112. '' ** First get the drive letter from the full Filename
  1113. ' If InStr(FName$, ":") Then
  1114. '  NameOFDrive$ = Left$(FName$, 1)
  1115. '   If NameOFDrive$ <> "" And NameOFDrive$ <> " " Then
  1116. ' '**********************************************
  1117. '      NameOFDrive$ = Trim$(NameOFDrive$) + ":"
  1118. ' '**********************************************
  1119. '   Else
  1120. '      NameOFDrive = ""
  1121. '      NODrive = True
  1122. '   End If
  1123. ' End If
  1124.  
  1125. ' ' ** Check if there is any Path in the string represented bei "\"
  1126. ' If InStr(FName$, "\") Then
  1127. '    BS% = 0
  1128. '    ' ** Find the last BackSlash in FName
  1129. '    Do
  1130. '      BS1% = BS% + 1
  1131. '      BS% = InStr(BS1%, FName$, "\")
  1132. '    Loop Until BS% = 0
  1133.  
  1134. '    ' ** If BS is greater then 2, we found a path, so get the name!
  1135. '    If BS1% > 2 Then
  1136. ' '*******************************************
  1137. '       NameOfPath$ = Left$(FName$, BS1% - 2)
  1138. ' '*******************************************
  1139. '    Else
  1140. '       NameOfPath$ = "\"
  1141. '       NOPath = True
  1142. '    End If
  1143. '    ' ** Finally we get the Filename here or we just found patterns !!
  1144. '    NameOFFile$ = Mid$(FName$, BS1%)
  1145. '    If InStr(FName$, "*") Or InStr(FName$, "?") Then
  1146. ' '******************************
  1147. '       NameOFPattern$ = FName$
  1148. ' '******************************
  1149. '       NOFile = True
  1150. '    End If
  1151. ' Else
  1152. ' '******************************
  1153. '    NameOFFile$ = FName$
  1154. ' '******************************
  1155. '    NOPath = True
  1156. '    NODrive = True
  1157. ' End If
  1158.  
  1159. ' PT% = InStr(FName$, ".")
  1160. ' If Len(PT%) <> 0 Then
  1161. ' '***********************************
  1162. '    NameOFExt$ = Mid$(FName$, PT%)
  1163. ' '***********************************
  1164. '    LenF% = Len(NameOFFile$) - 4
  1165. '    NameOFPurFile$ = Left$(NameOFFile, LenF%)
  1166. ' Else
  1167. '    NameOFExt = ""
  1168. '    NOExt = True
  1169. ' End If
  1170.  
  1171. ' ' ** Check if the Pathname we found is complete or add a BS.or not.
  1172. ' If Right$(NameOfPath$, 1) <> "\" Then
  1173. '    NameOfPath$ = NameOfPath$ + "\"
  1174. ' End If
  1175. ' If Right$(NameOfPath$, 1) = "\" Then
  1176. '    NameOfPathNoSL$ = Trim$(Right$(NameOfPath$, Len(NameOfPath$) - 1))
  1177. ' End If
  1178.  
  1179. '  ' ** Decide what do we have to return in case of GetBack value
  1180. '  Select Case GetBack%
  1181. '   Case 1     ' --------------------[A]-> Get Driveletter ('A:')
  1182. '     SplitFileName = NameOFDrive$
  1183. '   Case 2     ' --------------------[B]-> Get checked Path ('C:\TEST\' with '\')
  1184. '     SplitFileName = NameOfPath$
  1185. '   Case 3     ' --------------------[C]-> Get Filename plus Ext ('TEST.TXT')
  1186. '     SplitFileName = NameOFFile$
  1187. '   Case 4     ' --------------------[D]-> Get Extension of File ('.DOC')
  1188. '     SplitFileName = NameOFExt$
  1189. '   Case 5     ' --------------------[E]-> Get Pattern or ? ('*.EXE or ?.?')
  1190. '     SplitFileName = NameOFPattern$
  1191. '   Case 6     ' --------------------[F]-> Get just the Filename no EXT ('TEST')
  1192. '     SplitFileName = NameOFPurFile$
  1193. '   Case 7     ' --------------------[G]-> Get Path Name ('C:\TEST' -> no '\')
  1194. '     SplitFileName = NameOfPathNoSL$
  1195. '   Case Is > 7
  1196. '     SplitFileName = FName$
  1197. '   Case Is < 1
  1198. '     SplitFileName = ""
  1199. '  End Select
  1200.  
  1201. 'End Function
  1202.  
  1203. [Stop]
  1204. [41]
  1205. Get Windows System Directory
  1206.  
  1207. [Code]
  1208. 'Declares for Get Windows Path
  1209. WinSysPath$ = SystemDirectory ()
  1210.  
  1211.  
  1212. 'Function SystemDirectory () As String
  1213. 'Dim WinPath As String
  1214.  
  1215. '' ** Use API-call to get the windows-system pathname
  1216. ''    which is usually -> 'C:\WINDOW\SYSTEM' ...
  1217. '    WinPath = String(145, Chr(0))
  1218. '    SystemDirectory = Left(WinPath, GetSystemDirectory(WinPath, Len(WinPath)))
  1219. 'End Function
  1220.  
  1221. [Stop]
  1222. [42]
  1223. Call Application and execute. Flag driven for different state of Appl.
  1224.  
  1225.  
  1226. [Code]
  1227. 'Declares for Call External Application
  1228. R% = CallExtApplication (ByVal Flag%, ByVal Status%)
  1229.  
  1230.  
  1231. Function CallExtApplication (ByVal Flag%, ByVal Status%) As Integer
  1232. Dim FN$, lHnd%
  1233.  
  1234. '   Flags:  -> 1 = Notepad       Status: -> 1,5,9 = Normal+Focus     
  1235. '                -> 2 = Calculator                      2     = Minim+Focus     
  1236. '                -> 3 = Write                              3     = Maxm+Focus      
  1237. '                -> 4 = ....                                  4,8   = Normal+NoFocus   
  1238. '                -> 5 = ....                                  6,7   = Minim+NoFocus   
  1239.  
  1240.    Select Case Flag%
  1241.     Case 1
  1242.     lHnd% = Shell("notepad.exe", Status%)
  1243.     Status% = 1 '-> default
  1244.     Case 2
  1245.     lHnd% = Shell("calc.exe", Status%)
  1246.     Case 3
  1247.     lHnd% = Shell("write.exe", Status%)
  1248.    End Select
  1249.  
  1250.  CallExtApplication = lHnd%
  1251.  
  1252. End Function
  1253.  
  1254.  
  1255. [Stop]
  1256. [43]
  1257. Check if '\' is there or not?
  1258. [Code]
  1259. 'Declares for Check Path String ('\' ?)
  1260. Path$ = CheckPath (Pfad$)
  1261.  
  1262.  
  1263. Function CheckPath$ (Pfad$)
  1264.  ' ** Add Backslash to PathName if necessary
  1265.  If Right$(Pfad$, 1) <> "\" Then
  1266.    CheckPath$ = Pfad$ + "\"
  1267.  Else
  1268.    CheckPath$ = Pfad$
  1269.  End If
  1270. End Function
  1271. [Stop]
  1272. [44]
  1273. Clear contents of Listbox via API-call
  1274.  
  1275. [Code]
  1276. 'Declares for Clear ListBox
  1277. ClearListBox (Ctrl As Control)
  1278.  
  1279.  
  1280. Sub ClearListBox (Ctrl As Control)
  1281. Dim X%, hWndOld%, Suc%
  1282. Const LB_RESETCONTENT = &H400 + 5
  1283.  
  1284.  ' ** Just backup the old handle number
  1285.  '    because we need to restore this later.
  1286.  hWndOld% = GetFocus()
  1287.  
  1288.  ' ** Use api-function for fast clear method.
  1289.  X% = SendMessage(agGetControlHWnd(Ctrl), LB_RESETCONTENT, 0, 0&)
  1290.  
  1291.  ' ** If we are successfull restore old handle.
  1292.  Suc% = APISetFocus(hWndOld%)
  1293.  
  1294. End Sub
  1295.  
  1296. [Stop]
  1297. [45]
  1298. CS File Copy routine, copies files to destination...
  1299. [Code]
  1300. 'Declares for File Copy
  1301. CSFileCopy (Source$, Dest$, Copied, ErrCode%)
  1302.  
  1303.  
  1304. Static Sub CSFileCopy (Source$, Dest$, Copied, ErrCode%)
  1305.  Dim X, Path$, Count%, SrcName$, DestName$, Buffer$
  1306.     '----- Source$ may include a drive letter, a path, or wild cards
  1307.     '----- Dest$ may be a drive or path name only
  1308.  
  1309.     For X = Len(Source$) To 1 Step -1   'search for a "\" or ":"
  1310.         If Mid$(Source$, X, 1) = "\" Or Mid$(Source$, X, 1) = ":" Then Exit For
  1311.     Next
  1312.     Path$ = Left$(Source$, X)           'path is anything up to "\"
  1313.  
  1314.     If Len(Path$) And Right$(Path$, 1) <> "\" And Right$(Path$, 1) <> ":" Then
  1315.        Path$ = Path$ + "\"
  1316.     End If
  1317.  
  1318.     If Len(Dest$) And Right$(Dest$, 1) <> "\" And Right$(Dest$, 1) <> ":" Then
  1319.        Dest$ = Dest$ + "\"
  1320.     End If
  1321.  
  1322.     ErrCode = 1                     'an error here would be on the source
  1323.     Count = FCount%(Source$)        'count the number of matching files
  1324.     If DosError() Then Exit Sub     'the door was open or something
  1325.     If Count = 0 Then               'there were no matching files
  1326.        SetError 53                  'show the caller that no files matched
  1327.        Exit Sub                     'and say goodbye
  1328.     End If
  1329.  
  1330.     ReDim Array$(0 To Count)        'make an array to hold their names
  1331.     For X = 1 To Count              'fill with spaces
  1332.         Array$(X) = Space$(12)
  1333.     Next
  1334.     Array$(0) = Source$             'put the spec into element zero
  1335.     ReadFile Array$(0)              'and use ReadFile to get them
  1336.  
  1337.     Copied = 0                           'track how many are actually copied
  1338.     For X = 1 To Count                   'copy each file
  1339.         SrcName$ = Path$ + Array$(X)     'get full path for source
  1340.         DestName$ = Dest$ + Array$(X)    'get full path for dest
  1341.  
  1342.         FCopy SrcName$, DestName$, ErrCode% 'copy the file
  1343.         If DosError%() Then Exit For     'exit loop if an error
  1344.         Copied = Copied + 1              'show that another one was copied
  1345.     Next
  1346.  
  1347.     Buffer$ = ""                         'free up the memory
  1348.     Erase Array$                         '  ditto
  1349.  
  1350. End Sub
  1351. [Stop]
  1352. [46]
  1353. Counts numbers of def. Delimitters within a given string.
  1354.  
  1355. [Code]
  1356. 'Declares for Delimitter
  1357. NumberOfDelimitter% = Delimit (Work$, Delim$)
  1358.  
  1359.  
  1360. Static Function Delimit% (Work$, Delim$)
  1361. Dim Counter%, X%
  1362.  
  1363.   Counter% = 0
  1364.    For X% = 1 To Len(Delim$)
  1365.       Counter% = Counter% + InCount%(Work$, Mid$(Delim$, X%, 1))
  1366.    Next X%
  1367.   Delimit% = Counter% '-> Return Number of Delim$.
  1368. End Function
  1369.  
  1370. [Stop]
  1371. [47]
  1372. Get number of current device colors (Windows system)
  1373. [Code]
  1374. 'Declares for Get Color
  1375. NoColor& = DeviceColors (hDC As Integer)
  1376.  
  1377.  
  1378. Function DeviceColors (hDC As Integer) As Long
  1379. Const PLANES = 14
  1380. Const BITSPIXEL = 12
  1381.   ' ** Use the API-function to get current number of available Windows Colors.
  1382.   DeviceColors = GetDeviceCaps(hDC, PLANES) * 2 ^ GetDeviceCaps(hDC, BITSPIXEL)
  1383. End Function
  1384. [Stop]
  1385. [48]
  1386. Get File Errors and returns response number=Cancel, Ok, Retry...
  1387.  
  1388.  
  1389. [Code]
  1390. 'Declares for File Errors
  1391. err = FileErrors (errVal As Integer)
  1392.  
  1393.  
  1394. Function FileErrors (errVal As Integer) As Integer
  1395.  
  1396.  
  1397. Dim MsgType%, Response%
  1398.  
  1399. MsgType% = MB_EXCLAIM
  1400. FileErrors = 100
  1401. ' ** Reaktion depending on Error number
  1402. Select Case errVal
  1403.   Case Err_DeviceUnavailable                        ' -----> Error #68
  1404.       Msg = "(ERROR: 8100) File Error: Device not available."
  1405.       MsgType% = MB_EXCLAIM + 5
  1406.   Case Err_DiskFull                                 ' -----> Error #61
  1407.       Msg = "(ERROR: 8110) File Error: Local disk is full.."
  1408.   Case Err_DiskNotReady                             ' -----> Error #71
  1409.       Msg = "(ERROR: 8120) File Error: Device not ready."
  1410.   Case Err_DeviceIO                                 ' -----> Error #57
  1411.       Msg = "(ERROR: 8130) File Error: Device access denide."
  1412.   Case Err_BadFileName                              ' -----> Error #58
  1413.       Msg = "(ERROR: 8140) File Error: File already exist."
  1414.   Case Err_BadFileName                              ' -----> Error #52
  1415.       Msg = "(ERROR: 8150) File Error: File name is illegal."
  1416.   Case Err_PathDoesNotExist                         ' -----> Error #76
  1417.       Msg = "(ERROR: 8160) File Error: Path doesn't exist."
  1418.   Case Err_FileNotFound                             ' -----> Error #53
  1419.       Msg = "(ERROR: 8170) File Error: File was not found."
  1420.   Case Err_BadFileMode                              ' -----> Error #54
  1421.       Msg = "(ERROR: 8180) File Error: Can't open file."
  1422.   Case Err_FileAlreadyOpen                          ' -----> Error #55
  1423.       Msg = "(ERROR: 8190) File Error: File is already open."
  1424.   Case Err_InputPastEndOfFile                       ' -----> Error #62
  1425.       Msg = "(ERROR: 8195) File Error: Use of a nonstandard marker,"
  1426.   Case Else
  1427.       FileErrors = 3
  1428.       Exit Function
  1429.   End Select
  1430.  
  1431.   Response% = MsgBox(Msg, MsgType%, "File Error")
  1432.   Select Case Response%
  1433.      Case 4          ' Retry button.
  1434.      FileErrors = 0
  1435.      Exit Function
  1436.      Case 5          ' Ignore button.
  1437.      FileErrors = 1
  1438.      Exit Function
  1439.      Case 1, 2, 3    ' Ok and Cancel buttons.
  1440.      FileErrors = 2
  1441.      Exit Function
  1442.      Case Else       ' No idea.
  1443.      FileErrors = 3
  1444.      Exit Function
  1445.   End Select
  1446.  
  1447. End Function
  1448.  
  1449.  
  1450. [Stop]
  1451. [49]
  1452. Opens FName and reads all Section Header and add them to a ListBox.
  1453.  
  1454. [Code]
  1455. 'Declares for Get INI-Section
  1456. GetIniHeaders (FiName As String, Ctrl As Control)
  1457.  
  1458.  
  1459. Sub GetIniHeaders (FiName As String, Ctrl As Control)
  1460. Dim FiNum%, IniLine$, out$
  1461.  
  1462. ' ** After Header is found read all Items line by line
  1463.  FiNum% = FreeFile
  1464.  Open FiName For Input As FiNum%
  1465.   ' ** Read lines until end of file is reached
  1466.   Do While Not EOF(FiNum%)
  1467.      Input #FiNum%, IniLine$
  1468.      ' ** Read one line into buffer
  1469.      IniLine$ = RTrim$(LTrim$(IniLine$))
  1470.       If Left$(IniLine$, 1) = "[" Then
  1471.      ' ** Cut the breakets '[' out of the string here
  1472.      out$ = Mid$(IniLine$, 2, Len(IniLine$) - 2)
  1473.      ' ** Add item to listbox (Control = Ctrl)
  1474.      Ctrl.AddItem out$
  1475.       End If
  1476.   Loop
  1477.  Close #FiNum%
  1478. End Sub
  1479.  
  1480. [Stop]
  1481. [50]
  1482. Open INI FName and returns all items of sections within a ListBox.
  1483.  
  1484. [Code]
  1485. 'Declares for Get INI items
  1486. GetIniItems (FiName As String, Head As String, Ctrl As Control)
  1487.  
  1488.  
  1489. Sub GetIniItems (FiName As String, Head As String, Ctrl As Control)
  1490. Dim FiNum%, IniLine$, out$, lo%
  1491.  
  1492.  ' ** Get free filenumber and clear the listbox first
  1493.  FiNum% = FreeFile
  1494.  If Ctrl.ListCount > 0 Then Ctrl.Clear
  1495.  
  1496.   ' ** Open *.ini file and read all header into list
  1497.   Open FiName For Input As FiNum%
  1498.  
  1499.   ' ** Read each line until first heading is found
  1500.   Do While (Not EOF(FiNum%)) And (IniLine$ <> "[" + Head + "]")
  1501.      ' ** Read the line into the Stringbuffer
  1502.      Input #FiNum%, IniLine$
  1503.      ' ** Cut all spaces left+right from Str$
  1504.      IniLine$ = RTrim$(LTrim$(IniLine$))
  1505.   Loop
  1506.   ' ** Do this loop for all other headings.
  1507.   ' ** Do until next heading
  1508.   If (Not EOF(FiNum%)) Then
  1509.      Do
  1510.       Input #FiNum%, IniLine$
  1511.       ' ** Trim each line to avoid empty strings
  1512.       IniLine$ = RTrim$(LTrim$(IniLine$))
  1513.       ' ** Check if first character is [ => we found a header !
  1514.       If (Left$(IniLine$, 1) <> "[") And (Len(IniLine$) > 0) Then
  1515.      ' ** Check if there is any subitem + value, we look
  1516.      '    for '=' as indicator to find it
  1517.      lo% = InStr(IniLine$, "=") - 1
  1518.      If (lo > 0) Then
  1519.         ' ** Add header to listbox if all conditions are true
  1520.         out$ = Left$(IniLine$, lo%)
  1521.         Ctrl.AddItem LTrim$(RTrim$(out$))
  1522.      End If
  1523.       End If
  1524.      ' ** Repeat all this until we reached the file-end.
  1525.      Loop While (Not EOF(FiNum%)) And (Left$(IniLine$, 1) <> "[")
  1526.   ' ** End if we reached the end of file FiNum !
  1527.   End If
  1528.   Close #FiNum%
  1529. End Sub
  1530.  
  1531. [Stop]
  1532. [51]
  1533. Flexible loading function, loads any filetype to a buffer var...
  1534.  
  1535. [Code]
  1536. 'Declares for Load File to Buffer
  1537. R% =  LoadFileTObuf (FName$, Mode%, RecLen&, ControlType$)
  1538.  
  1539.  
  1540. Function LoadFileTObuf (FName$, Mode%, RecLen&, ControlType$) As Integer
  1541. Dim Num%, FNum%, Fmode%
  1542.  
  1543.  
  1544. ' ** Set to true and define the Filenumber
  1545. LoadFileTObuf = True
  1546. FNum% = FreeFile
  1547. Fmode% = Mode%
  1548. On Error GoTo ERROR_FILE_LOADING
  1549.  
  1550.   ' ** Check what kind of action is expected
  1551.   Select Case Fmode%
  1552.      Case REPLACEFILE  ' ** OverWrite the ascii file completely
  1553.       Open FName$ For Output As FNum%
  1554.       Print #FNum%, ControlType
  1555.      Case READFILEIN     ' ** Load the file contents into control buffer
  1556.       Open FName$ For Input As FNum%
  1557.       ControlType = Input$(LOF(FNum%), FNum%)
  1558.      Case ADDTOFILE    ' ** Add text or var.-control buf to the file
  1559.       Open FName$ For Append As FNum%
  1560.       Print #FNum%, ControlType
  1561.      Case RANDOMFILE   ' ** Sequential reading of the record sets
  1562.       Open FName$ For Random As FNum% Len = RecLen
  1563.       ControlType = Input$(LOF(FNum%), FNum%)
  1564.      Case BINARYFILE   ' ** Load binary file into controle (i.e picture)
  1565.       Open FName$ For Binary As FNum%
  1566.       ControlType = Input$(LOF(FNum%), FNum%)
  1567.      Case Else
  1568.       Exit Function
  1569.   End Select
  1570.   Close FNum%
  1571.   Exit Function
  1572.  
  1573. ERROR_FILE_LOADING:
  1574.   LoadFileTObuf = False
  1575.     Num = FileErrors(Err)
  1576.   Resume Next
  1577. End Function
  1578.  
  1579. [Stop]
  1580. [52]
  1581. Extract individual components from a single string and place each element in a string array, needs delimitters to work properly.
  1582.  
  1583. [Code]
  1584. 'Declares for Parse String
  1585. Parse (Work$, Delim$, Array$())
  1586.  
  1587.  
  1588. Sub Parse (Work$, Delim$, Array$())
  1589. Dim BeginPtr&, EndPtr&, Element&
  1590.  
  1591.   BeginPtr& = 1
  1592.   Element& = 1
  1593.    For EndPtr& = 1 To Len(Work$)
  1594.       If InStr(Delim$, Mid$(Work$, EndPtr&, 1)) Then
  1595.         Array$(Element&) = Mid$(Work$, BeginPtr&, EndPtr& - BeginPtr&)
  1596.         Element& = Element& + 1
  1597.         BeginPtr& = EndPtr& + 1
  1598.       End If
  1599.   Next       'Array$(1)
  1600.   '-> Store last Components to array.
  1601.   Array$(Element&) = Mid$(Work$, BeginPtr&, EndPtr& - BeginPtr&)
  1602.  
  1603. End Sub
  1604.  
  1605. [Stop]
  1606. [53]
  1607. Read File to string
  1608.  
  1609. [Code]
  1610. 'Declares for Read File
  1611. BufStr$ = ReadFileTOstring (F$)
  1612.  
  1613.  
  1614. Function ReadFileTOstring (F$) As String
  1615. Dim FN%, indTxt%, TLine$, Buf$
  1616. On Error GoTo READ_FILE_TOSTRING_ERROR
  1617.  
  1618.  FN% = FreeFile              '<- Get Filenumber for F$.
  1619.  indTxt% = 0                 '<- Set line count to zero.
  1620.  TLine$ = ""                 '<- Set line buffer to 0.
  1621.  Buf$ = ""
  1622.  CL = Chr(13) + Chr(10) '<** Carriage Return and Line Feed ***
  1623.  ReadFileTOstring = ""
  1624.  
  1625.  Open F$ For Input As FN%     '<- Open/Input text File F$,
  1626.    Do While Not EOF(FN%)      '<- Loop until end of file (eof).
  1627.      Input #FN%, TLine$       '<- read one line into Tline$.
  1628.       'TLine$ = TLine$ + CL
  1629.      indTxt% = indTxt% + 1    '<- Get number of lines in F$.
  1630.      Buf$ = Buf$ + TLine$ + CL'<- Add text to buffer each time.
  1631.      TLine$ = ""
  1632.    Loop
  1633.  
  1634.  ReadFileTOstring = Buf$      '<- Copy Buf$-text to function.
  1635.  
  1636.  Exit Function                '<- We must exit here otherwise,
  1637.                   '   we jump into ReadError.
  1638. READ_FILE_TOSTRING_ERROR:
  1639.   R% = FileErrors(Err)        '<- Call file error function.
  1640.   ReadFileTOstring = "ERROR"  '<- Write ERROR-str$ to function.
  1641.   Resume 1013                 '<- Don't stop go to next proc.
  1642. 1013 :
  1643.   indTxt% = 0                 '<- Set line count to zero.
  1644.   TLine$ = "ERROR"            '<- Set line buffer to 0.
  1645.   Buf$ = "ERROR Reading File to String"
  1646. End Function
  1647.  
  1648. [Stop]
  1649. [54]
  1650. Exit current appl. and restart windows.
  1651.  
  1652. [Code]
  1653. 'Declares for Restart Windows
  1654. RestartSystem (ByVal Res As Integer)
  1655.  
  1656.  
  1657. Sub RestartSystem (ByVal Res As Integer)
  1658. Dim Res%
  1659.  
  1660.  Reset '-> Close all open files first.
  1661.  ' ** API restart function call
  1662.  Res% = ExitWindows(EW_RESTARTWINDOWS, 0)
  1663. End Sub
  1664.  
  1665. [Stop]
  1666. [55]
  1667. Pause running system for def seconds.
  1668.  
  1669. [Code]
  1670. 'Declares for Wait - Delay
  1671. Wait (sec As Integer)
  1672.  
  1673.  
  1674. Sub Wait (sec As Integer)
  1675. Dim Count%
  1676.  
  1677. ' The Unit of 'sec' is miliseconds [ms]
  1678. ' example:
  1679. ' ========
  1680. ' If sec(ms)=1000 ==> Wait = 1 second !
  1681. '--------------------------------------
  1682.   For Count% = 1 To sec
  1683.   Next Count%
  1684. End Sub
  1685.  
  1686. [Stop]
  1687.